home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / Module source / Decompile < prev    next >
Encoding:
Text File  |  1995-11-08  |  17.5 KB  |  596 lines  |  [TEXT/YERK]
  1. \ Yerk Disassembler
  2. \  1/16/86  cdn Initial version
  3. \  1/20/86  cdn Handle named input parameters and local variables
  4. \  2/24/86  cdn Added detection of Immediate words
  5. \                Added RANGEOF
  6. \  6/01/86  cdn Added (++>), (EX>), (TRAP), (DEFER), (JMP), COMPILE
  7. \  6/02/86  cdn Added deClass, deObj, deModule, etc…
  8. \  8/11/86  cdn Added multiple cfa recognition
  9. \  8/25/86  cdn Added method decompilation
  10. \  6/29/87    rfl Added the first three cases to handle floats
  11. \ 12/17/87    rfl Fixed .num to show signs
  12. \  1/11/90    rfl Fixed ?isobj,?isclass,?ismod,?isvect,.32-bit etc. for protection
  13. \                  against invalid RAM
  14. \  3/14/90    rfl    nhash now wordcol; took out ?isobj since now in Class
  15. \ 10/03/90    rfl    added protection for lit numbers out of app range
  16. \ 10/26/90    rfl changed /module to |module so can decompile words with '/' in them
  17. \ 12/16/90    rfl    added offCol instead of old ordered-col
  18. \  3/29/91    rfl fixed slight bug setting 0 -> #p in decol
  19. \ 10/26/91    rfl    undid a reserve back to allot in name/hash
  20. \  2/25/92    rfl    fixed super/self problem with decompiling a class method
  21. \  5/14/93    rfl    now decompiles vect, value, and sysvec contents too.
  22. \  6/17/93    rfl    fixed another super/self problem when de' a method
  23. \  6/22/93    rfl added support for float named input and local vars
  24. \  7/16/93    rfl    after 3.64 release, redefined 'inapprange?' to use heapbot and top
  25. \  7/21/93    rfl    added inapprange? to 32-bit
  26. \ 12/29/93    rfl    no longer crashes on mcode
  27. \  4/5/94    rfl    added space to flit
  28. \  5/4/94    rfl    added check for exit
  29.  
  30. \ de' will decompile colon definitions and methods of classes; follow with a
  31. \ slash-module name to decompile module code.  Named stack parms and local vars
  32. \ are indicated by a curly bracket syntax like the one used to compile them,
  33. \ however their actual names are no longer known after compilation so symbolic
  34. \ names parmN & varN are shown.  Method selectors are also unavailable after
  35. \ compilation since they are hashed, so the common sequence: meth: obj
  36. \ decompiles as: ???: obj.  Methods bound to ivars within class definitions
  37. \ are shown by the offset of the ivar data within the object.  eg: ???: 12
  38. \ Anything completely unrecognized will display as ¿¿¿
  39. \
  40. \ "deflgs" bits:
  41. \ 0 - print absolute address of each item
  42. \ 1 - print relative address of each item
  43. \ 2 - print offset of each item
  44. \ 3 - display super class data
  45. \ 4 - display nested ivar stuctures
  46. \ 5 - display indexed data
  47.  
  48. :module deMod
  49.  
  50. 0 value tab
  51. : indent tab 4* out - 0 max spaces ;
  52.  
  53. : .bld  1 tFace ;    \ print in bold
  54. : .exp 64 tFace ;    \ print in expanded
  55. : .nor  0 tFace ;    \ revert to normal mode
  56. : .hash .bld ."   hash:" . .nor ;
  57.  
  58. \ : sign rot 0< IF 45 hold THEN ;
  59. \ ( val -- )
  60. : .num dup abs 0 <# #s sign #> type ;
  61.  
  62. 0 value start
  63. \ Print address and/or offset of datum
  64. : .addr { addr -- }
  65.     .bld
  66.     deflgs 01 and IF addr +base   .num ascii : emit THEN
  67.     deflgs 02 and IF addr         .num ascii : emit THEN
  68.     deflgs 04 and IF addr start - .num ascii : emit THEN
  69.     .nor ;
  70.  
  71. : NewL ?pause
  72.     CR dup .addr
  73.     0 -> out indent ;
  74.  
  75. : ?NewL
  76.     out tab 4* - 0> IF NewL THEN ;
  77.  
  78. \ ( addr -- addr' )  print "parmN" or "varN"
  79. : .p/v
  80.     dup @ >name 3+ c@ dup 48 - mp0 <    \ mp0 is a peek at deComp's "#p" var
  81.     IF ." parm" ELSE ." var" THEN
  82.     emit space  4+ ;
  83.  
  84. \ ( addr -- addr' )  print "parmN" or "varN"
  85. : .%p/v
  86.     dup    @ >name  4+ c@ dup 48 - mp0 <    \ mp0 is a peek at deComp's "#p" var
  87.     IF ." %parm" ELSE ." %var" THEN
  88.     emit space  4+ ;
  89.  
  90. 0 value nflgs
  91. \ ( pfa -- )  print name of definition and save name field flags
  92. : .nfa nfa dup id. c@ -> nflgs ;
  93.  
  94. :CLASS  wArray  <Super  Object  2 <Indexed
  95.  
  96.     :M  AT:        ?idx ^Elem  w@             ;M
  97.     :M  TO:        ?idx ^Elem  w!            ;M
  98.  
  99. ;CLASS
  100.  
  101. :CLASS wordCol  <Super wArray
  102.  
  103.     Int        Size    \ # elements in list
  104.  
  105.     \ ( -- curSize )  Return #elements currently in list
  106.     :M  SIZE:  Get: Size  ;M
  107.  
  108.     \ ( val -- )   Add value to end of list
  109.     :M  ADD:  Get: Size  limit  >=
  110.         classErr" 137  Get: size  To: Self
  111.         1 +: Size   ;M
  112.  
  113.     \ ( val -- ind t  OR f)  Find a value in an OC
  114.     :M  INDEXOF:  0 swap Get: Size  0
  115.         DO i  (^elem) w@
  116.             over = IF 2drop  i 1 1 leave THEN
  117.         LOOP  drop  ;M
  118.  
  119. ;CLASS
  120.  
  121. :CLASS OffArray <super wordCol
  122.  
  123.     var    pointer
  124.  
  125.   :M init: ( addr --) put: pointer ;M
  126.   :M at: ( ind -- addr) at: super get: pointer + ;M
  127.   :M add: ( addr --) get: pointer - add: super ;M
  128.  
  129. ;CLASS
  130.  
  131. 472 WordCol nHash
  132. 472 OffArray hName
  133. : name/hash here init: hName
  134.     new: loadFile
  135.     " name/hash" name: topFile
  136.     openReadOnly: topFile IF ." No name/hash table available" exit THEN
  137.     BEGIN
  138.         tib 128 expect: topFile 0=
  139.     WHILE
  140.         bytesRead: topFile 1-
  141.         tib over here >str255 here c@ >uc
  142.         here hash add: nHash
  143.         here add: hName
  144.         1+ allot
  145.     REPEAT
  146.     remove: loadFile
  147. ;
  148. name/hash
  149.  
  150. \ ( val -- )
  151. : .mName
  152.     indexOf: nhash
  153.     IF at: hName count type space
  154.     ELSE ." ???: " THEN ;
  155.  
  156. : inAppRange? ( addr -- addr b) dup heapBot heapTop within ;
  157.  
  158. \ ( pfa #parms -- )  Decompile cfas starting from pfa
  159. : deComp { #p \ ;? cf? skipExit -- }    \ #p number of parms, ;? end of defintion flag
  160.     0 -> ;? 0 -> skipExit
  161.     1 ++> tab indent
  162.     BEGIN    ( addr )
  163.         dup @
  164.         CASE    ( addr cfa )
  165.         'c flit            OF  4+ dup print: float 10 + space            ENDOF
  166.         'c killfargs    OF    ." KillFargs" 6 +                        ENDOF
  167.         'c !fp(ip)        OF  ." -> "  4+ dup w@ 8 - 4 / $ 30 + ." %parm" emit 2+    space ENDOF
  168.         'c +fp(ip)        OF  ." ++> " 4+ dup w@ 8 - 4 / $ 30 + ." %parm" emit 2+    space ENDOF
  169.         'c lit            OF    4+ dup @
  170.                             over 4+ @ dup 'c trap = swap 'c (fdos) = or
  171.                             IF ." $" .h
  172.                             ELSE inAppRange?
  173.                                 IF ?cfa
  174.                                     IF ." 'c " >name id.
  175.                                     ELSE dup cfa ?cfa
  176.                                         IF drop ." ' " nfa id.
  177.                                         ELSE drop .num space
  178.                                         THEN
  179.                                     THEN
  180.                                 ELSE .
  181.                                 THEN
  182.                             THEN 4+                                    ENDOF
  183.         'c wlit            OF    4+ dup w@
  184.                             over 2+ @ dup 'c trap = swap 'c (fdos) = or
  185.                             IF ." $" .h
  186.                             ELSE dup cfa inAppRange?
  187.                                 IF ?cfa
  188.                                     IF drop ." ' " nfa id.
  189.                                     ELSE drop .num space
  190.                                     THEN
  191.                                 ELSE .
  192.                                 THEN
  193.                             THEN 2+                                    ENDOF
  194.         'c wlitw        OF    4+ ." w" dup w@ . 2+                    ENDOF
  195.         'c (lits)        OF    4+ ?NewL dup w@ ." <[" dup . ." ]> 'cfas "
  196.                             swap 2+ swap 0
  197.                             DO dup @ >name id. 4+ LOOP                ENDOF
  198.         'c (trap)        OF    4+ ascii $ emit
  199.                             base >R hex
  200.                                 dup w@ . ." Trap " 2+
  201.                             R> -> base                                ENDOF
  202.         'c [trap]        OF        4+ ascii $ emit
  203.                             base >R hex
  204.                                 dup w@ . ." Trap " 12 +
  205.                             R> -> base                                ENDOF
  206.         'c (defer)        OF    4+ dup w@ .mName ." [ ] " 2+            ENDOF
  207.         'c (classerr")    OF    4+ ." ClassErr" ascii " emit
  208.                             dup w@ . 2+                                ENDOF
  209.         'c (.rAbort)    OF    4+ ." ?error"
  210.                             dup w@ . 2+                                ENDOF
  211.         'c (.rStr)        OF    4+ ." msg#"
  212.                             dup w@ . 2+                                ENDOF
  213.         'c (.tStr)        OF    4+ ." type#"
  214.                             dup w@ . 2+                                ENDOF
  215.         'c compile        OF    4+ ." Compile " dup @ >name id. 4+        ENDOF
  216.         'c branch        OF    4+ ." Branch:"  dup @ dup .
  217.                             over + dup -> skipExit .addr 4+    NewL    ENDOF
  218.         'c 0branch        OF    4+ ." 0Branch:" dup @ dup .
  219.                             over + dup -> skipExit .addr 4+    NewL    ENDOF
  220.         'c (do)            OF    8+ ?NewL ." DO "    1 ++> tab    NewL    ENDOF
  221.         'c (loop)        OF    8+ -1 ++> tab        ?NewL  ." LOOP "     ENDOF
  222.         'c (loop+)        OF    8+ -1 ++> tab        ?NewL ." +LOOP "     ENDOF
  223.         'c (of)            OF    4+ ." OF "    dup @ over + ->  skipExit
  224.                             4+                                        ENDOF
  225.         'c (rof)        OF    4+ ." RANGEOF "    dup @ over + -> skipExit
  226.                             4+                                        ENDOF
  227.         'c (select)        OF    4+ ?NewL ." Select{" NewL
  228.                             @ dup dup dup @ - 4 / 1- 0
  229.                             DO    i . ." is{ " 4- dup @ #p deComp
  230.                                 ." }end"  NewL
  231.                             LOOP ." default{ "
  232.                             4- @ #p deComp
  233.                             ?NewL ." }Select" 4+ NewL                ENDOF
  234.         'c (.")            OF    4+ ascii . emit ascii " emit space
  235.                             count 2dup type ascii " emit space
  236.                             + align                                    ENDOF
  237.         'c (lit")        OF    4+ ascii " emit space
  238.                             count 2dup type ascii " emit space
  239.                             + align                                    ENDOF
  240.         'c (ab")        OF    4+ ." Abort" ascii " emit space
  241.                             count 2dup type ascii " emit space
  242.                             + align                                    ENDOF
  243.         'c (al")        OF    4+ ." Alert" ascii " emit space
  244.                             count 2dup type ascii " emit space
  245.                             + align                                    ENDOF
  246.         'c (disp)        OF    4+ ." Dispose> " dup @ 8- nfa id. 4+    ENDOF
  247.         'c (mdisp)        OF    4+ ." Dispose> " dup w@ dup #p <
  248.                             IF ." parm" ELSE ." var" THEN
  249.                             48 + emit space 2+                        ENDOF
  250.         'c (be)            OF    ." Become " 4+                            ENDOF
  251.         'c (semip)        OF    dup skipExit <
  252.                             IF 4+ ." Exit " 0 -> skipExit ELSE drop 1 -> ;? THEN    ENDOF
  253.         'c (jmp)        OF    4+ @ .exp ." ( Forward referenced )"
  254.                                  .nor                        NewL    ENDOF
  255.         'c ;s            OF    dup skipExit <
  256.                             IF 4+ ." Exit " 0 -> skipExit ELSE drop 1 -> ;?    THEN            ENDOF
  257.         'c (;m)            OF    drop                    1 -> ;?            ENDOF
  258.         'c (;code)        OF    drop CR ." (;CODE) "    1 -> ;?            ENDOF
  259.         'c (,code)        OF    drop CR ." BUILD "        1 -> ;?            ENDOF
  260.         'c header        OF    10 + dup 2- w@ 4 / 0
  261.                             DO  NewL .exp i .num ." cfa: " .nor
  262.                                 NewL dup @ 10 + 0 deComp CR 4+
  263.                             LOOP drop                1 -> ;?            ENDOF
  264.         'c @fp0            OF  .%p/v                                    ENDOF
  265.         'c @fp1            OF  .%p/v                                    ENDOF
  266.         'c @fp2            OF  .%p/v                                    ENDOF
  267.         'c @fp3            OF  .%p/v                                    ENDOF
  268.         'c @fp4            OF  .%p/v                                    ENDOF
  269.         'c @fp5            OF  .%p/v                                    ENDOF
  270.         'c mp0            OF    .p/v                                    ENDOF
  271.         'c mp1            OF    .p/v                                    ENDOF
  272.         'c mp2            OF    .p/v                                    ENDOF
  273.         'c mp3            OF    .p/v                                    ENDOF
  274.         'c mp4            OF    .p/v                                    ENDOF
  275.         'c mp5            OF    .p/v                                    ENDOF
  276.         'c ms0            OF    ." -> " .p/v                            ENDOF
  277.         'c ms1            OF    ." -> " .p/v                            ENDOF
  278.         'c ms2            OF    ." -> " .p/v                            ENDOF
  279.         'c ms3            OF    ." -> " .p/v                            ENDOF
  280.         'c ms4            OF    ." -> " .p/v                            ENDOF
  281.         'c ms5            OF    ." -> " .p/v                            ENDOF
  282.         'c (++>)        OF    4+ dup w@ 8- 4 / dup #p < ." ++> "
  283.                             IF ." parm" ELSE ." var" THEN
  284.                             48 + emit space 2+                        ENDOF
  285.         'c (ex>)        OF    4+ dup w@ 8- 4 / dup #p < ." exec> "
  286.                             IF ." parm" ELSE ." var" THEN
  287.                             48 + emit space 2+                        ENDOF
  288.         \ OTHERWISE
  289.  
  290.             dup >body ?isObj    \ normal early bound method?
  291.             IF    drop    ( addr cfa )
  292.                 over 4+ @ @ ' m0cfa =
  293.                 IF    over 4+ @ 6 - w@ .mName >name id. 8+
  294.                     deflgs 07 and IF dup 4- @ 6 - w@ .hash THEN
  295.                 ELSE >name id. 4+ THEN
  296.  
  297.             ELSE drop    ( addr cfa )
  298.  
  299.                 dup @ ' m1cfa =        \ method bound to a private ivar?
  300.                 IF    10 - w@ .mName 4+
  301.                     dup w@ 65535 over =    \ check for self/super ref
  302.                     IF    drop dup 4- @ start <
  303.                         IF ." super" ELSE ." self" THEN
  304.                     ELSE .num THEN space 2+
  305.                     deflgs 07 and IF dup 6 - @ 10 - w@ .hash THEN
  306.  
  307.                 ELSE    ( addr cfa )
  308.  
  309.                     dup @ ' m0cfa =    \ method bound to a class
  310.                     IF    dup 6 - w@ .mName
  311.                         latest BEGIN 2dup < WHILE pfa lfa @ REPEAT id. drop
  312.                         4+
  313.  
  314.                     ELSE    ( addr cfa )
  315.                         ?cfa                    \ ultimately, this is the usual case
  316.                         IF >name dup id. n>count " INLINE" s=
  317.                             IF 4+ BEGIN dup w@ dup $ 49fa <>
  318.                                WHILE ascii $ emit .h 2+
  319.                                     out 60 > IF NewL THEN
  320.                                REPEAT 
  321.                                 drop 4+     
  322.                             THEN
  323.                         ELSE 1 -> cf? 9 1
  324.                             DO  cfa ?cfa    \ check for nth cfa
  325.                                 IF dup @ >R  valCode R =    vectCode R  = or
  326.                                             fvalCode R = or   svCode R> = or
  327.                                     IF i 1 = IF ." ++> " ELSE ." -> " THEN
  328.                                     ELSE 48 i+ emit 45 emit THEN
  329.                                     >name id. 0 -> cf? leave
  330.                                 THEN
  331.                             LOOP
  332.                             cf? IF drop ." ¿¿¿ " THEN    \ all decomp failed
  333.                         THEN
  334.                         4+
  335.                     THEN
  336.  
  337.                 THEN
  338.             THEN
  339.  
  340.             dup    \ for consumption by endcase
  341.  
  342.         ENDCASE
  343.  
  344.         deflgs 07 and    \ print address and/or offset?
  345.         IF
  346.             NewL    \ new line for every word
  347.         ELSE
  348.             out 60 > IF NewL THEN
  349.         THEN
  350.  
  351.     ;? UNTIL
  352.     nflgs $ 40 and IF ." Immediate" THEN
  353.     -1 ++> tab
  354. ;
  355.  
  356. 0 value floatpos
  357. : isFloatP/V ( pos  --) floatPos and IF ascii % emit THEN ;
  358.  
  359. \ ( pfa -- )  decompile a definition; may have named stack
  360. : deCol { myPfa \ amt #p -- }    \ #p number of parms
  361.     0 -> #p
  362.     myPfa c@                        \ Does definition has named stack or local vars
  363.     IF    ." { "
  364.         myPfa c@ -> amt                \ get the total number of parms and vars
  365.         myPfa 1+ c@ -> floatPos        \ get position of any floats
  366.         amt $ F and -> #p            \ look at parms first
  367.         #p 0 DO i 1+ isFloatP/V ." parm" 48 i+ emit space LOOP
  368.         amt 4 >> -dup
  369.         IF ascii \ emit space 0 DO 1 #p i+ << isFloatP/V ." var" 48 #p + i+ emit space LOOP THEN
  370.         ." -- }" myPfa 2+ -> myPfa
  371.     THEN
  372.     NewL myPfa #p deComp ;
  373.  
  374. : NxtL ?pause
  375.     CR 0 -> out indent ;
  376.  
  377. \ ( pfa -- )  decompile a class definition
  378. : deClass { ^class \ k -- } CR
  379.     0 -> k    1 -> tab
  380.     ^class mfa @    \ get starting addresses of method
  381.     BEGIN dup ^class >
  382.     WHILE 1 ++> k dup 2+ @
  383.     REPEAT drop
  384.     ." :CLASS " ^class nfa id.
  385.     ."  <Super " ^class 22 + @ nfa id.
  386.     ^class 20 + w@ -dup IF . ." <Indexed" THEN CR
  387.     ^class 18 + w@ NxtL .exp ." (" . ." Bytes )" .nor CR
  388.     k 0 DO
  389.         NewL ." :M  " dup w@ .mName 10 + dup @
  390.         over 4+ = IF drop ." is an MCode definition" ELSE 4+ deCol THEN
  391.         NewL ." ;M" CR
  392.     LOOP
  393.     CR ." ;CLASS"
  394. ;
  395.  
  396. 0 value odata
  397. : .) ascii ) emit ;
  398. : .( .addr ascii ( emit ;
  399.  
  400. : .32-bit
  401.     dup . inAppRange?
  402.     IF ?cfa
  403.         IF >name id. ELSE drop THEN
  404.     ELSE drop
  405.     THEN ;
  406.  
  407. \ ( length -- )  display a fundamental datum from the object
  408. : .odata { w -- }
  409.     odata .(
  410.     w CASE
  411.         1 OF odata c@ .       ENDOF
  412.         2 OF odata w@ .       ENDOF
  413.         4 OF odata  @ .32-bit ENDOF
  414.     \ OTHERWISE
  415.     w . ." Bytes "    \ if not 1, 2 or 3; just tell how many bytes there are
  416.     ENDCASE
  417.     .)
  418.     w ++> odata
  419. ;
  420.  
  421. \ display indexed data cells with their indices
  422. : .idata { \ width -- }
  423.     odata w@ -> width 4 ++> odata    \ get width and skip indexed header
  424.     odata 2- w@ 0
  425.     DO    NxtL
  426.         i . width .odata            \ print the contents of each element
  427.     LOOP
  428. ;
  429.  
  430. Forward .struct
  431.  
  432. \ display contents of ivar
  433. : .ivars { lastNFA 1stNFA dlen \ inc -- }
  434.     lastNFA 12 + 1stNFA
  435.     DO    12 -> inc            \ usual length of an ivar
  436.         NxtL
  437.         i 6 + @                \ get ivars class pointer
  438.         dup ' Object =
  439.         IF    ." DATA " drop     \ This ivar is DATA
  440.             i lastNFA =        \ If last ivar, can't subtract from next ivar
  441.             IF dlen            \ computes # bytes
  442.             ELSE i 22 + w@ THEN
  443.                  i 10 + w@ - .odata
  444.         ELSE
  445.             dup nfa     id.                \ This ivar may be nested
  446.             dup @width                     \ indexed?
  447.             dup IF 14 -> inc
  448.                    4 ++> odata THEN        \ (get past indexed overhead)
  449.             over ifa @ 3 pick 26 + > or    \ nest?
  450.             deflgs 16 and lAnd            \ supposed to be displaying nested?
  451.             IF 1 ++> tab .struct -1 ++> tab
  452.             ELSE dfa w@ .odata THEN
  453.         THEN
  454.     inc +LOOP
  455. ;
  456.  
  457. 0 value snest
  458.  
  459. \ ( ^class -- )  print ivar data & indexed data (recursive from .ivars & self)
  460. :f .struct 
  461.     1 ++> snest
  462.     dup dfa w@            \ total length of object data
  463.     over sfa @ dfa w@    \ length of super class data
  464.     tab 0= over lAnd deflgs 08 and lAnd
  465.     IF  3 pick dup sfa @ dup nfa CR ." --" id. CR    \ display super data
  466.         .struct              nfa CR ." ==" id. CR
  467.     ELSE dup ++> odata THEN        \ skip super data
  468.     - -dup                \ total data minus super data
  469.     IF over ifa @                    \ pointer to last ivar
  470.         3 pick 26 +                    \ pointer to first ivar
  471.         rot .ivars                    \ print ivar data
  472.     ELSE tab 0= IF .exp ." ( No ivars )" .nor CR THEN THEN
  473.     @width                            \ print indexed data if any
  474.     IF deflgs 32 and snest 0= lAnd
  475.         IF    NxtL .exp ." --Indexed Data--" .nor
  476.             .idata
  477.         THEN
  478.     THEN
  479.     -1 ++> snest 
  480. ;f
  481.  
  482. \ ( pfa -- )  display the data of an object
  483. : deObj CR
  484.     dup here >
  485.     IF ." HEAP-OBJECT "
  486.     ELSE dup nfa id. THEN        \ otherwise print object name
  487.     dup -> odata                \ set start of data
  488.     .exp ." is an Object of Class: " .nor
  489.     cfa @ dup nfa id.            \ print superclass name
  490.      -1 -> snest  0 -> tab
  491.     .struct                        \ print ivar data & indexed data
  492. ;
  493.  
  494. \ ( pfa -- )  decompile a module definition
  495. : deModule { \ #imps -- }
  496.     ." From " dup nfa id. ." Import{ "
  497.     dup 16 + w@ -> #imps 12 + @
  498.     #imps 1- 0 DO        \ gather export words
  499.         dup pfa lfa @
  500.     LOOP
  501.     #imps 0 DO            \ print export word names
  502.         id.
  503.     LOOP
  504.     ." }"
  505. ;
  506.  
  507. 0 constant con
  508. 0 variable vare
  509.  
  510. \ ( pfa -- pfa bool )
  511. : ?isMod modCode over cfa (@) drop = ;
  512. ' does> 20 + constant doesCode
  513.  
  514. \ ( pfa -- )  setup for one of the decompilers: Colon, Class, Object, etc…
  515. : (de) ?pause
  516.     dup -> start    0 -> nflgs    0 -> tab
  517.     dup cfa @ over = IF nfa id. .exp ." is a Code word" .nor CR exit THEN
  518.     ?isObj   IF deObj CR exit THEN
  519.     ?isClass IF deClass CR exit THEN
  520.     ?isMod   IF deModule CR exit THEN
  521.     dup cfa @    ( pfa code )
  522.     dup colCode = over ' colP = or
  523.     IF drop CR ." : " dup .nfa deCol CR ." ; " CR exit THEN
  524.  
  525.     CASE
  526.     over .nfa .exp    ( pfa code )
  527.  
  528.     valCode   OF .bld ." is a Value " .nor 8+ dup .( @ dup .32-bit .) cr
  529.                     ?isobj IF (de) ELSE drop THEN             ENDOF
  530.     fvalCode  OF ." is an fValue" .nor drop                  ENDOF
  531.     impCFA    OF ." is an Import word " .nor dup .( space @ >name id. .)
  532.                  nflgs $ 40 and IF CR ." Immediate" THEN    ENDOF
  533.     'code con OF ." is a Constant " .nor dup .( @ .32-bit .) ENDOF
  534.     'code vare OF ." is a Variable " .nor dup .( @ .32-bit .) ENDOF
  535.     vectCode  OF .bld ." is a Vect " .nor 8+ dup .( @ -dup IF 4+ dup nfa space id. .) cr (de)
  536.                                     ELSE 0 . .) THEN        ENDOF
  537.     svCode    OF ." is a sysVect " .nor 8+ dup 4+
  538.                  begin-dp @ rot @ + dup @ 0= IF drop dup THEN
  539.                  dup .( @ 4+ dup nfa space id. ." ) … default "
  540.                  swap dup .( @ >name space id. .)    cr (de)            ENDOF
  541.     doesCode  OF @ latest BEGIN 2dup < WHILE pfa lfa @ REPEAT
  542.                 ." is a " id. ." definition" .nor drop        ENDOF
  543.  
  544.     \ OTHERWISE    ( pfa code )
  545.  
  546.         ' (dodo) over 2+ @ =
  547.         IF    0 >R latest BEGIN 2dup < WHILE R> drop dup >R pfa lfa @ REPEAT
  548.             ." is a " R> id. ." definition" .nor 2drop
  549.         ELSE
  550.             dup 4- @ over =
  551.             IF     ." is an alias of " .nor nfa id.
  552.             ELSE ." is a MYSTERY" .nor drop THEN
  553.         THEN
  554.  
  555.     ENDCASE
  556.     CR
  557. ;
  558.  
  559. \ ( str255 chr -- offs t OR f )
  560. : charOf { adr chr -- }
  561.     0    \ bool
  562.     adr c@ 1+ 1
  563.     DO
  564.         adr i+ c@ chr = IF drop i 1- 1 leave THEN
  565.     LOOP
  566. ;
  567.  
  568. \ ( str -- nfa )  lookup module vocabulary if specified; else main dictionary
  569. : dvoc { str -- }
  570.     str ascii | charOf
  571.     IF    str over 1+ over c@ over - str rot + c! c!    \ double string
  572.         str count + latest (find) 0= Abort" not found" drop
  573.         ?isMod 0= Abort" not a module"
  574.         dup cfa execute        \ get module into memory
  575.         8+ @ $ ffffff and
  576.            @ $ ffffff and    \ get nfa of last word in module
  577.     ELSE latest THEN ;
  578.  
  579. \ decompile any yerk word or method
  580. \ de' word[|module]
  581. \ de' meth: class[|module]
  582. : de'
  583.     @word dup c@ over + c@ ascii : =
  584.     IF    dup count str255 drop hash        \ method of a class
  585.         @word dup
  586.         dvoc (find) 0= Abort" not found" drop
  587.         ?isClass 0= Abort" not a class"
  588.         dup -> start (findm) ." :M  " buf255 count type 4+ deCol
  589.         CR ." ;M" CR
  590.     ELSE                                \ normal word
  591.         dup dvoc (find) 0= Abort" not found" drop
  592.         (de)
  593.     THEN ;
  594.  
  595. ;Module
  596.